;;; ---------------------------------------------------------------------------
;;;   License: LGPL-2.1+ (See file 'Copyright' for details).
;;; ---------------------------------------------------------------------------
;;;
;;; (c) copyright 2005 Aleksandar Bakic <a_bakic@yahoo.com>
;;;
;;; ---------------------------------------------------------------------------
;;;
;;; Adaptation of binary sequences by Robert Will (real-world-phenomena.org)
;;; Optimized version of binseq.lisp:
;;;   the contents of a leaf node must not be nil nor a cons.

(in-package #:binseq)

(defun obinseq-p (s)
  (or (null s)
      (atom s)
      (and (consp s)
           (and (integerp (car s)) ; might wanna check the value
                (consp (cdr s))
                (obinseq-p (cadr s))
                (obinseq-p (cddr s))))))

(defun list-obinseq (l)
  (flet ((%split (l n) ; TODO: use side-effects to avoid consing
           (loop for b on l
              and i from 0
              if (< i n)
              collect (car b) into a
              else do (return (values a b))
              finally (return (values l nil)))))
    (cond
      ((null l) nil)
      ((null (cdr l))
       (let ((e (car l)))
       (assert (and e (atom e)) nil
               "Sequence element must be a non-nil atom: ~S" e)
       e))
      (t (let ((len (length l)))
           (multiple-value-bind (a b) (%split l (floor len 2))
             `(,len . (,(list-obinseq a) . ,(list-obinseq b)))))))))

(defun obinseq-list (s)
  (labels ((%to-list (s l)
             (cond
               ((null s) nil)
               ((atom s) (cons s l))
               (t (%to-list (cadr s) (%to-list (cddr s) l))))))
    (%to-list s nil)))

(defun vector-obinseq (v &optional (start 0) (end (length v)))
  (cond
    ((= start end) nil)
    ((= (- end start) 1)
     (let ((e (aref v start)))
       (assert (and e (atom e)) nil
               "Sequence element must be a non-nil atom: ~S" e)
       e))
    (t (let* ((len (- end start))
              (mid (+ start (floor len 2))))
         `(,len . (,(vector-obinseq v start mid) .
                    ,(vector-obinseq v mid end)))))))

(defun obinseq-vector (s)
  (let ((v (make-array (obinseq-length s))))
    (labels ((%set-v (s o)
               (cond
                 ((null s))
                 ((atom s) (setf (aref v o) s))
                 (t (let ((a (cadr s))
                          (b (cddr s)))
                      (%set-v a o)
                      (%set-v b (+ o (obinseq-length a))))))))
      (%set-v s 0)
      v)))

(defun obinseq-empty (s)
  (null s))

(defun obinseq-length (s)
  (cond
    ((null s) 0)
    ((atom s) 1)
    (t (car s))))

(defun obinseq-cons (e s)
  (obinseq-append e s))

(defun obinseq-snoc (e s)
  (obinseq-append s e))

(defun obinseq-append (a b)
  (labels ((%not-much-longer (a b)
             (<= (obinseq-length a) (* *imbalance-bound* (obinseq-length b))))
           (%much-shorter (a b)
             (not (%not-much-longer b a)))
           (%similar-in-length (a b)
             (and (%not-much-longer a b) (%not-much-longer b a)))
           (%cond-single (la lb lc)
             (and (<= lb (* *imbalance-bound* lc))
                  (<= (+ lb lc) (* *imbalance-bound* la))))
           (%cond-double (la lb lc)
             (<= (+ la lb) (* (+ 1 *imbalance-bound*) lc)))
           (%cons (a b)
             (let ((len (+ (obinseq-length a) (obinseq-length b))))
               (assert (>= len 2))
               `(,len . (,a . ,b))))
           (%rotate-right (s1 s2)
             (cond
               ((consp s1)
                (let* ((a (cadr s1))
                       (b (cddr s1))
                       (la (obinseq-length a))
                       (lb (obinseq-length b))
                       (ls2 (obinseq-length s2)))
                  (cond
                    ((%cond-single la lb ls2)
                     (%cons a (%cons b s2)))
                    ((%cond-double la lb ls2)
                     (let ((s11 (cadr b))
                           (s12 (cddr b)))
                       (%cons (%cons a s11) (%cons s12 s2))))
                    (t (%append a (%append b s2))))))
               (t (%append a (%append b s2)))))
           (%rotate-left (s1 s2)
             (cond
               ((consp s2)
                (let* ((a (cddr s2))
                       (b (cadr s2))
                       (la (obinseq-length a))
                       (lb (obinseq-length b))
                       (ls1 (obinseq-length s1)))
                  (cond
                    ((%cond-single la lb ls1)
                     (%cons (%cons s1 b) a))
                    ((%cond-double la lb ls1)
                     (let ((s21 (cddr b))
                           (s22 (cadr b)))
                       (%cons (%cons s1 s22) (%cons s21 a))))
                    (t (%append (%append s1 b) a)))))
               (t (%append (%append s1 b) a))))
           (%append (a b)
             (cond
               ((%similar-in-length a b)
                (%cons a b))
               ((%much-shorter a b)
                (%rotate-left a b))
               (t (%rotate-right a b)))))
    (cond
      ((null a) b)
      ((null b) a)
      (t (%append a b)))))

(defun obinseq-front (s i)
  (cond
    ((<= i 0) nil)
    ((<= (obinseq-length s) i) s)
    ((<= i (obinseq-length (cadr s))) (obinseq-front (cadr s) i))
    (t (obinseq-append
        (cadr s)
        (obinseq-front (cddr s) (- i (obinseq-length (cadr s))))))))

(defun obinseq-back (s i)
  (cond
    ((<= i 0) nil)
    ((<= (obinseq-length s) i) s)
    ((<= i (obinseq-length (cddr s))) (obinseq-back (cddr s) i))
    (t (obinseq-append
        (obinseq-back (cadr s) (- i (obinseq-length (cddr s))))
        (cddr s)))))

(defun %ohas-index (s i)
  (and (<= 0 i) (< i (obinseq-length s))))

(defun %ohas-gap (s i)
  (and (<= 0 i) (<= i (obinseq-length s))))

(defun obinseq-get (s i)
  (assert (%ohas-index s i) nil "Index out of bounds: ~S, ~S" s i)
  (obinseq-back (obinseq-front s (1+ i)) 1))

(defun obinseq-set (s i e)
  (assert (%ohas-index s i) nil "Index out of bounds: ~S, ~S, ~S" s i e)
  (obinseq-append
   (obinseq-front s i)
   (obinseq-cons e (obinseq-back s (- (obinseq-length s) i 1)))))

(defun obinseq-sub (s i n)
  (assert (and (>= n 0) (<= (+ i n) (obinseq-length s))) nil
          "Invalid subsequence bounds: ~S, ~S, ~S" s i n)
  (obinseq-back (obinseq-front s (+ i n)) n))

(defun obinseq-insert (s i e)
  (assert (%ohas-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i e)
  (obinseq-append
   (obinseq-front s i)
   (obinseq-cons e (obinseq-back s (- (obinseq-length s) i)))))

(defun obinseq-insert* (s i s2)
  (assert (%ohas-gap s i) nil "Index out of bounds: ~S, ~S, ~S" s i s2)
  (if (null s2)
      s
      (obinseq-append
       (obinseq-front s i)
       (obinseq-append s2 (obinseq-back s (- (obinseq-length s) i))))))

(defun obinseq-remove (s i)
  (assert (%ohas-index s i) nil "Index out of bounds: ~S, ~S" s i)
  (obinseq-append
   (obinseq-front s i)
   (obinseq-back s (- (obinseq-length s) i 1))))

(defun obinseq-remove* (s i n)
  (assert (%ohas-index s i) nil "Start index out of bounds: ~S, ~S, ~S" s i n)
  (assert (and (>= n 0) (<= (+ i n) (obinseq-length s))) nil
          "Count out of range: ~S, ~S, ~S" s i n)
  (if (zerop n)
      s
      (obinseq-append
       (obinseq-front s i)
       (obinseq-back s (- (obinseq-length s) i n)))))
